(define-module (parse-context-free)
  #:use-module ((srfi srfi-1) #:select (every))
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module (derivative parse context-free)
  #:use-module (derivative utils sets))

(define-syntax with-error-to-null
  (syntax-rules ()
    ((_ body ...)
     (with-error-to-file "/dev/null"
       body ...))))

(test-begin "parse-context-free")

(test-assert "derivative: rep language"
  (let ((lang (rep #\x)))
    (match (D #\x lang)
      (($ <cat> _ (= force L))
       (equal? L lang))
      (else #f))))

(define compact
  (@@ (derivative parse context-free) compact))

(test-assert "compaction: alt: empty this"
  (match (compact (alt 'empty (eps* #\x)))
    (($ <eps*> _) #t)
    (else #f)))
(test-assert "compaction: alt: empty that"
  (match (compact (alt (eps* #\x) 'empty))
    (($ <eps*> _) #t)
    (else #f)))
(test-assert "compaction: alt: nested empty"
  (match (compact (alt (cat #\x #\y 'empty)
		       (eps* #\x)))
    (($ <eps*> (= set->list (#\x))) #t)
    (else #f)))
(test-assert "compaction: alt: destructive empty"
  (match (compact (alt (cat #\x 'empty)
		       (cat #\y 'empty)))
    ('empty #t)
    (else #f)))
(test-assert "compaction: alt: nullable"
  (match (compact (alt (eps* #\x) (eps* #\y)))
    (($ <eps*> _) #t)
    (else #f)))
(test-assert "compaction: alt: recursive"
  (match (compact (alt (alt (cat #\x 'empty) #\y) #\z))
    (($ <alt> (= force #\y) (= force #\z)) #t)
    (else #f)))
(test-assert "compaction: cat: left empty"
  (match (compact (cat 'empty #\x))
    ('empty #t)
    (else #f)))
(test-assert "compaction: cat: right empty"
  (match (compact (cat #\x 'empty))
    ('empty #t)
    (else #f)))
(test-assert "compaction: cat: fully nullable"
  (match (compact (cat (eps* #\x) (eps* #\y)))
    (($ <eps*> _) #t)
    (else #f)))
(test-assert "compaction: cat: left nullable"
  (match (compact (cat (eps* #\x) #\y))
    (($ <red> (= force (? char?)) _) #t)
    (else #f)))
(test-assert "compaction: cat: right nullable"
  (match (compact (cat (alt #\x #\y) (eps* #\z)))
    (($ <red> (= force ($ <alt> _ _)) _) #t)
    (else #f)))
(test-assert "compaction: red: empty"
  (match (compact (red (cat #\x 'empty) identity))
    ('empty #t)
    (else #f)))
(test-assert "compaction: red: nullable"
  (match (compact (red (eps* #\y #\z) char-upcase))
    (($ <eps*> T)
     (and (set-contains? T #\Y)
	  (set-contains? T #\Z)))
    (else #f)))
(test-assert "compaction: red: nested nullable"
  (match (compact (red (red (eps* #\y) char->integer) 1+))
    (($ <eps*> (= set->list (122))) #t)
    (else #f)))
(test-assert "compaction: red: nested"
  (match (compact (red (red (alt #\x #\y) char->integer) 1+))
    (($ <red> (= force ($ <alt> (= force #\x) (= force #\y))) f)
     (= (f #\y) 122))			;f should be the composition
    (else #f)))

(test-equal "parse: cat"
  '((#\x #\y . #\z))
  (parse "xyz" (cat #\x #\y #\z)))
(test-equal "parse: alt"
  '(#\x)
  (parse "x" (alt #\x #\y)))
(test-equal "parse: rep"
  '((#\x #\x #\x))
  (parse "xxx" (rep #\x)))
(test-equal "parse: rep alt"
  '((#\x #\y))
  (parse "xy" (rep (alt #\x #\y))))
(test-equal "parse: red"
  '(120)
  (parse "x" (red #\x char->integer)))

(test-assert "parse: any"
  (every (negate (compose null? (cut parse <> any)))
	 '("x" "X" "(" ")" "." "_" "1" "2" "^" "→")))
(test-equal "parse: one-of: list"
  '((#\x #\y #\z))
  (parse "xyz" (rep (one-of '(#\w #\x #\y #\z)))))
(test-equal "parse: one-of: string"
  '((#\x #\y #\z))
  (parse "xyz" (rep (one-of "zyxw"))))
(test-equal "parse: one-of: char-set"
  '((#\a #\b #\x))
  (parse "abx" (rep (one-of char-set:lower-case))))
(test-equal "parse: one-of: char-set fail"
  '()
  (with-error-to-null
    (lambda () (parse "abX" (rep (one-of char-set:lower-case))))))
(test-equal "parse: none-of"
  '((#\A #\B #\C))
  (parse "ABC" (rep (none-of char-set:lower-case))))
(test-equal "parse: none-of fail"
  '()
  (with-error-to-null
   (lambda () (parse "ABCxDEF" (rep (none-of char-set:lower-case))))))
(test-equal "parse: string"
  '("hello, world!")
  (parse "hello, world!" (string "hello, world!")))
(test-equal "parse: string fail"
  '()
  (with-error-to-null
   (lambda ()
     (parse "hello" (string "hello, world!")))))

(test-equal "parse: middle"
  '("hello")
  (parse "(hello)" (middle #\( (red (rep any) list->string) #\))))
(test-equal "parse: count"
  '((#\x #\x #\x))
  (parse "xxx" (count 3 #\x)))
(test-equal "parse: count fail"
  '()
  (with-error-to-null
   (lambda () (parse "xxx" (count 4 #\x)))))
(test-equal "parse: count'"
  (list (make-list 4 "foo"))
  (parse "foofoofoofoo" (count 4 (string "foo"))))
(test-equal "parse: many: empty"
  '(())
  (parse "" (many #\x)))
(test-equal "parse: many"
  (list (make-list 5 #\x))
  (parse "xxxxx" (many #\x)))
(test-equal "parse: many fail"
  '()
  (with-error-to-null
   (lambda () (parse "xxxyxx" (many #\x)))))
(test-equal "parse: many+: empty"
  '()
  (with-error-to-null
   (lambda () (parse "" (many+ #\x)))))
(test-equal "parse: many+"
  (list (make-list 5 #\x))
  (parse "xxxxx" (many+ #\x)))
(test-equal "parse: many+ fail"
  '()
  (with-error-to-null
   (lambda () (parse "xxxyxx" (many+ #\x)))))
(test-equal "parse: maybe: absent"
  '((() #\y #\y))
  (parse "yy" (cat (maybe #\x) (rep #\y))))
(test-equal "parse: maybe"
  '((#\x #\y #\y))
  (parse "xyy" (cat (maybe #\x) (rep #\y))))
(test-equal "parse: trim-right"
  '("xy")
  (parse "xy  " (red (trim-right (many+ (one-of "xy")))
		     list->string)))
(test-equal "parse: trim-left"
  '((#\x #\y #\z))
  (parse "                        xyz"
	 (trim-left (many+ (one-of "abcxyz")))))
(test-equal "parse: trim"
  '((#\x #\x))
  (parse "                xx         " (trim (many+ #\x))))
(test-equal "parse: delimit"
  '("foo, bar, hello, world")
  (parse "foo bar  hello
                world"
	 (red (delimit whitespace+ (red lower-case+ list->string))
	      (cut string-join <> ", "))))

(test-equal "parse: tokens: symbols"
  '((foo . bar)
    (foo bar foo foo))
  (append (parse '(foo bar) (cat 'foo 'bar))
          (parse '(foo bar foo foo) (rep (alt 'foo 'bar)))))
(test-equal "parse: tokens: strings"
  '(("hello" . "world")
    ("foo" "foo" "foo")
    "fizz buzz fizz"
    "foo, bar, foo")
  (append (parse '("hello" "world") (cat "hello" "world"))
          (parse '("foo" "foo" "foo") (rep "foo"))
          (parse '("fizz" "buzz" "fizz")
                 (red (rep (alt "fizz" "buzz"))
                      string-join))
          (parse '("foo" "bar" "foo")
                 (red (rep (alt "foo" "bar"))
                      (cut string-join <> ", ")))))
(test-equal "parse: tokens: mixed"
  '(((1 2 3) . "gnu")
    (xwing . "fighter")
    42
    (#\r 2 d "two"))
  (append
   (parse '(1 2 3 "gnu") (cat (rep (token integer? "int"))
			      "gnu"))
   (parse '(#\x wing "fighter") (cat (red (cat (token char? "char")
					       (token symbol? "sym"))
					  (match-lambda
					    ((c . s)
					     (symbol-append ((@ (guile) symbol) c)
							    s))))
				     "fighter"))
   (parse '(23 7 8 4) (red (rep (token integer? "int"))
			   (lambda (i) (apply + i))))
   (parse '(#\r 2 d "two") (rep (token (const #t) "anything")))))

(test-equal "parse: parens 1"
  '((#\( ()  . #\)))
  (parse "()" parens-lang))
(test-equal "parse: parens 2"
  '((#\( (#\( () . #\))  . #\)))
  (parse "(())" parens-lang))
(test-equal "parse: parens 3"
  '(((#\( (#\( () . #\))  . #\)) #\( () . #\)))
  (parse "(())()" parens-lang))
(test-equal "parse: digit"
  '(#\4)
  (parse "4" digit))
(test-equal "parse: numeral"
  '(123)
  (parse "123" numeral-parser))
(test-equal "parse: term minus"
  '(103)
  (parse "123-20" term-parser))
(test-equal "parse: term plus"
  '(76)
  (parse "12+64" term-parser))
(test-equal "parse: term 3"
  '(74)
  (parse "12+64-2" term-parser))

;;; Check error-handling
(test-equal "parse: error handling"
  '("error: unexpected end-of-input
error: expecting `x'
"
    "error: parser collapsed at input `x'
error: expecting end-of-input
")
  (list (with-error-to-string
	  (lambda ()
	    (parse "xxxx" (count 5 #\x))))
	(with-error-to-string
	  (lambda ()
	    (parse "xxxx" (count 3 #\x))))))

(test-end "parse-context-free")
